home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / bootstrap.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  12KB  |  447 lines
  1. /* ******************************************************************** */
  2. /*  bootstrap.c      Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Rig up the basic Metaclasses/Classes                                 */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: bootstrap.c,v 1.6 1992/01/17 22:26:18 pab Exp $
  9.  *
  10.  * $Log: bootstrap.c,v $
  11.  * Revision 1.6  1992/01/17  22:26:18  pab
  12.  * deleted redundant function
  13.  *
  14.  * Revision 1.5  1992/01/09  22:28:43  pab
  15.  * Fixed for low tag ints
  16.  *
  17.  * Revision 1.4  1991/12/22  15:13:50  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.3  1991/11/15  13:44:21  pab
  21.  * copyalloc rev 0.01
  22.  *
  23.  * Revision 1.2  1991/09/11  12:07:00  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:49:27  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.2  1991/02/13  18:16:46  kjp
  30.  * Weak wrapper class + RCS log headers.
  31.  *
  32.  */
  33.  
  34. #define KJPDBG(x) 
  35.  
  36. /*
  37.  * Change Log:
  38.  *   Version 1, June 1989
  39.  */
  40.  
  41. #include <stdio.h>
  42. #include "funcalls.h"
  43. #include "defs.h"
  44. #include "structs.h"
  45. #include "global.h"
  46.  
  47. #include "bootstrap.h"
  48. #include "symboot.h"
  49. #include "allocate.h"
  50. #include "copy.h"
  51.  
  52. #include "slots.h"
  53. #include "ngenerics.h"
  54. /*
  55.  
  56.  * Should maybe turn all the symbol and class structure mallocs
  57.  * into statics...
  58.  
  59.  */
  60.  
  61. extern LispObject Basic_Structure;
  62. extern LispObject Primitive_Class;
  63. extern LispObject Thread_Class;
  64. extern LispObject Method_Class;
  65. extern LispObject Macro;
  66.  
  67. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  68. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  69.  
  70. /*
  71.  
  72.  * Special symbol initialisation...
  73.  
  74.  */
  75.  
  76. /* 
  77.  
  78.  * 'Place marker' class initialisation.
  79.  
  80.  */
  81. void gen_class_with_slots(LispObject *stacktop,
  82.               LispObject *obj,char *name,
  83.               LispObject class,LispObject super,
  84.               int local_count)
  85. {
  86.   gen_class(stacktop,obj,name,class,super);
  87.   (*obj)->CLASS.local_count = super->CLASS.local_count + local_count;
  88.  
  89. }
  90.  
  91. /* Also registers a new root */
  92.  
  93. void gen_class(LispObject *stackbase,
  94.            LispObject *obj,char *name,
  95.            LispObject class,LispObject super)
  96. {
  97.   LispObject sym, xx;
  98.   LispObject *stacktop=stackbase+2;
  99.   ARG_0(stackbase)=class;
  100.   ARG_1(stackbase)=super;
  101.  
  102.   sym = (LispObject) get_symbol(stacktop,name);
  103.   STACK_TMP(sym);
  104.  
  105.   *obj = (LispObject) allocate_class(stacktop,NULL);
  106.  
  107.   class=ARG_0(stackbase);
  108.   lval_classof(*obj) = class;
  109.  
  110.   UNSTACK_TMP(sym);
  111.   (*obj)->CLASS.name = sym;
  112.   
  113.   super=ARG_1(stackbase);
  114.   if (super == nil) (*obj)->CLASS.superclasses = nil;
  115.   else {
  116.     STACK_TMP(*obj);
  117.     EUCALLSET_2(xx,Fn_cons,super,nil);
  118.     UNSTACK_TMP(*obj);
  119.     (*obj)->CLASS.superclasses = xx;
  120.   }
  121.  
  122.   super=ARG_1(stackbase);
  123.   STACK_TMP(*obj);
  124.   EUCALLSET_2(xx, Fn_cons, *obj, (super->CLASS.subclasses==NULL?
  125.                                nil:super->CLASS.subclasses));
  126.  
  127.   super=ARG_1(stackbase);
  128.   super->CLASS.subclasses = xx;
  129.   UNSTACK_TMP(*obj);
  130.   (*obj)->CLASS.subclasses = nil;
  131.  
  132.   (*obj)->CLASS.slot_table = nil;
  133.   STACK_TMP(*obj);
  134.   EUCALLSET_2(xx, Fn_cons,(*obj),super->CLASS.precedence);
  135.   UNSTACK_TMP(*obj);
  136.   (*obj)->CLASS.precedence = xx;
  137.   (*obj)->CLASS.local_count = super->CLASS.local_count;
  138.   (*obj)->CLASS.slot_list = nil;
  139.   (*obj)->CLASS.direct_slot_list = nil;
  140. }
  141.  
  142. /*
  143.  
  144.  * Non-trivial class initialisation...
  145.  
  146.  */
  147.  
  148. void make_class(LispObject *stackbase,
  149.         LispObject class,char *name,LispObject meta,
  150.         LispObject parent,int local_count)
  151. {
  152.   LispObject lispname,tmp;
  153.   LispObject *stacktop=stackbase+3;
  154.   ARG_0(stackbase)=class;
  155.   ARG_1(stackbase)=parent;
  156.   ARG_2(stackbase)=meta;
  157.  
  158.   lispname = (LispObject) get_symbol(stacktop,name);
  159.  
  160.   class=ARG_0(stackbase);
  161.   meta=ARG_2(stackbase);
  162.   lval_classof(class) = meta;
  163.  
  164.   class->CLASS.name       = lispname;
  165.  
  166.   parent=ARG_1(stackbase);
  167.   tmp = (parent == nil ? nil : EUCALL_2(Fn_cons,parent,nil));
  168.   class=ARG_0(stackbase);
  169.   parent=ARG_1(stackbase);
  170.   class->CLASS.superclasses = tmp;
  171.  
  172.   /* Hack 'cos of mutual reference cases... */
  173.   if (parent != nil)
  174.     {
  175.       if (parent->CLASS.subclasses == NULL)
  176.     parent->CLASS.subclasses = nil;
  177.       else 
  178.     {
  179.       tmp = EUCALL_2(Fn_cons,class,parent->CLASS.subclasses); 
  180.       parent=ARG_1(stackbase);
  181.       parent->CLASS.subclasses = tmp;
  182.       class=ARG_0(stackbase);
  183.     }
  184.       /* Dang */
  185.     }
  186.   if (class->CLASS.subclasses == NULL) class->CLASS.subclasses = nil;
  187.  
  188.   if (parent != nil)
  189.       tmp = EUCALL_2(Fn_cons,class,parent->CLASS.precedence);
  190.   else
  191.     tmp = EUCALL_2(Fn_cons,class,nil);
  192.   
  193.   class=ARG_0(stackbase);
  194.   parent=ARG_1(stackbase);
  195.   class->CLASS.precedence = tmp;
  196.  
  197.   class->CLASS.slot_table = nil;
  198.   /* kernel is single inheritance */
  199.   class->CLASS.local_count  = (parent==nil) ? local_count:
  200.                                       parent->CLASS.local_count + local_count;
  201.  
  202.   class->CLASS.slot_list = nil;
  203.   class->CLASS.direct_slot_list = nil;  
  204. }
  205.  
  206. /* 
  207.  
  208.  * Useful (?) things for generating lists of lisp objects...
  209.  
  210.  */
  211.  
  212. LispObject make_list_1(LispObject *stacktop,LispObject obj)
  213. {
  214.   return( EUCALL_2(Fn_cons,obj,nil));
  215. }
  216.  
  217. LispObject make_list_2(LispObject *stacktop,LispObject obj1,LispObject obj2)
  218. {
  219.   LispObject xx;
  220.   STACK_TMP(obj1);
  221.   xx = make_list_1(stacktop,obj2);
  222.   UNSTACK_TMP(obj1);
  223.   return( EUCALL_2(Fn_cons,obj1,xx));
  224. }
  225.  
  226. /*
  227.  
  228.  * Set up all the provided classes + special symbols.
  229.  
  230.  */
  231.  
  232. void bootstrap(LispObject *stacktop)
  233. {
  234.   /* Reserve space for the classes... 
  235.      ... non garbage and easy for self reference */
  236.  
  237.   /* Root object and root class - self referential... */
  238.  
  239.   Object          = (LispObject) allocate_class(stacktop,NULL);
  240.   Standard_Class  = (LispObject) allocate_class(stacktop,NULL);
  241.  
  242.   add_root(&Object); add_root(&Standard_Class); 
  243.   /* Slot Description objects */
  244.  
  245.   Slot_Description_Class 
  246.     = (LispObject) allocate_class(stacktop,NULL);
  247.   Slot_Description     
  248.     = (LispObject) allocate_class(stacktop,NULL);
  249.   Local_Slot_Description     
  250.     = (LispObject) allocate_class(stacktop,NULL);
  251.  
  252.   add_root(&Slot_Description_Class);
  253.   add_root(&Slot_Description);
  254.   add_root(&Local_Slot_Description);
  255.   /* Other good stuff */
  256.  
  257.   Structure_Class
  258.     = (LispObject) allocate_class(stacktop,NULL);
  259.  
  260.   /* For symbol bootstrapping... */
  261.  
  262.   Abstract_Class 
  263.     = (LispObject) allocate_class(stacktop,NULL);
  264.     
  265.   Symbol
  266.     = (LispObject) allocate_class(stacktop,NULL);
  267.  
  268.   Null
  269.     = (LispObject) allocate_class(stacktop,NULL);
  270.  
  271.   Cons 
  272.     = (LispObject) allocate_class(stacktop,NULL);
  273.  
  274.   add_root(&Structure_Class);
  275.   add_root(&Abstract_Class);
  276.   add_root(&Symbol); add_root(&Null);
  277.   add_root(&Cons);
  278.   /* Get nil... */
  279.  
  280.   EUCALLSET_2(nil, Fn_cons, NULL,NULL);
  281.   lval_typeof(nil) = TYPE_NULL;
  282.   add_root(&nil);
  283.   /* Fill it later... */
  284.   
  285.   /* Symbols and objects needed during class gen */
  286. /**
  287.   lisptrue 
  288.     = (LispObject) system_static_malloc(sizeof(struct symbol_structure));
  289. **/
  290.   /* Self evaluating symbols and nil */
  291.  
  292.   (void) make_special_symbol(stacktop,&lisptrue,"t");
  293.   (void) make_special_symbol(stacktop,&unbound,"*unbound*");
  294.   add_root(&lisptrue);    
  295.   add_root(&unbound);
  296.   /* Begin initialising... */
  297.  
  298.   /* Self referential and kernel classes first... */
  299.  
  300.   /* Note, this initialisation order is importand - parents must have been
  301.      initialised before inherited classes may be instantiated... */
  302.  
  303.   /* Object */
  304.  
  305.   make_class( stacktop,
  306.           Object,
  307.          "object",
  308.           Standard_Class,
  309.           nil,0 );
  310.  
  311.   /* Standard-Class */
  312.  
  313.   make_class( stacktop,
  314.           Standard_Class,                          /* Class to be made */
  315.          "class",                                  /* Name of same */
  316.           Standard_Class,                          /* Class of same */
  317.           Object,N_SLOTS_IN_CLASS );                                /* Parent */
  318.  
  319.   /* Slot_Description_Class */
  320.  
  321.   make_class( stacktop,
  322.           Slot_Description_Class,
  323.          "slot-description-class",
  324.           Standard_Class,
  325.           Standard_Class, 0);
  326.  
  327.   /* Slot_Description */
  328.   
  329.   make_class( stacktop,
  330.           Slot_Description,
  331.          "slot-description",
  332.           Slot_Description_Class,
  333.           Object, N_SLOTS_IN_SD_CLASS );        
  334.  
  335.   /* Local_Slot_Description */
  336.  
  337.   make_class( stacktop,
  338.           Local_Slot_Description,
  339.          "local-slot-description",
  340.           Slot_Description_Class,
  341.           Slot_Description, 0 );
  342.  
  343.   make_class( stacktop,
  344.           Structure_Class,
  345.          "structure-class",
  346.           Standard_Class,
  347.           Standard_Class, 0 );
  348.  
  349.   make_class( stacktop,
  350.           Abstract_Class,
  351.          "abstract-class",
  352.          Standard_Class,
  353.          Standard_Class, 0);
  354.  
  355.   gen_class(stacktop,&Primitive_Class,
  356.         "primitive-class",Standard_Class,Standard_Class);
  357.   add_root(&Primitive_Class);
  358.   gen_class(stacktop,&Thread_Class,
  359.         "thread-class",Standard_Class,Standard_Class);
  360.   add_root(&Thread_Class);
  361.  
  362.   /* Used in class generation... */
  363.  
  364.   make_class(stacktop,Cons,"pair",Primitive_Class,Object,0);
  365.   make_class(stacktop,Null,"null",Primitive_Class,Object,0);
  366.   make_class(stacktop,Symbol,"symbol",Primitive_Class,Object,0);
  367.  
  368.   /* The "place marker" classes */
  369.  
  370.   /* Metas */
  371.  
  372.   gen_class(stacktop,&Funcallable_Object_Class,"funcallable-object-class",
  373.         Standard_Class,Standard_Class);
  374.   add_root(&Funcallable_Object_Class);
  375.   gen_class(stacktop,&Pair_Class,"pair-class",Standard_Class,Standard_Class);
  376.   add_root(&Pair_Class);
  377.   gen_class(stacktop,&Unpredictable_Fixed_Size_Class,"unpredictable-fixed-size-class",
  378.         Standard_Class,Standard_Class);
  379.   add_root(&Unpredictable_Fixed_Size_Class);
  380.   gen_class(stacktop,&Variable_Size_Keyed_Class,"variable-size-keyed-class",
  381.         Standard_Class,Standard_Class);
  382.   add_root(&Variable_Size_Keyed_Class);
  383.   gen_class(stacktop,&Method_Class,"method-class",Standard_Class,Standard_Class);
  384.   add_root(&Method_Class);
  385.   gen_class(stacktop,&Generic_Class,"generic-class",
  386.         Standard_Class,Funcallable_Object_Class);
  387.   add_root(&Generic_Class);
  388.   gen_class(stacktop,&Number,   "number",   Primitive_Class,Object);
  389.   add_root(&Number);
  390.   gen_class(stacktop,&Complex,  "complex",  Primitive_Class,Number);
  391.   add_root(&Complex);
  392.   gen_class(stacktop,&Real,     "real",     Primitive_Class,Complex);
  393.   add_root(&Real);
  394.   gen_class(stacktop,&Rational, "rational", Primitive_Class,Real);
  395.   add_root(&Rational);
  396.   gen_class(stacktop,&Integer,  "integer",  Primitive_Class,Rational);
  397.   add_root(&Integer);
  398.   gen_class(stacktop,&Character,"character",Primitive_Class,Object);
  399.   add_root(&Character);
  400.   gen_class(stacktop,&String,   "string",   Primitive_Class,Object);
  401.   add_root(&String);
  402.   gen_class_with_slots(stacktop,&Thread,   "thread",Thread_Class,Object,
  403.                N_SLOTS_IN_THREAD);
  404.   add_root(&Thread);
  405.   gen_class(stacktop,&Function, "function", Funcallable_Object_Class,Object);
  406.   add_root(&Function);
  407.  
  408.   gen_class(stacktop,&Continue, "continuation",Funcallable_Object_Class,Function);
  409.   add_root(&Continue);
  410.   gen_class_with_slots(stacktop,&Generic,  
  411.                "generic-function",Generic_Class,Function,
  412.                N_SLOTS_IN_GENERIC_CLASS);
  413.   add_root(&Generic);
  414.   gen_class_with_slots(stacktop,&Method,   "method",   Method_Class,Object,
  415.                N_SLOTS_IN_METHOD_CLASS);
  416.   add_root(&Method);
  417.   gen_class(stacktop,&Macro,    "macro",    Funcallable_Object_Class,Function);
  418.   add_root(&Macro);
  419.   gen_class(stacktop,&Vector,"vector",Primitive_Class,Object);
  420.   add_root(&Vector);
  421.   gen_class(stacktop,&Table,"table",Primitive_Class,Object);
  422.   add_root(&Table);
  423.  
  424.   gen_class(stacktop,&Weak_Wrapper,"weak-wrapper",Primitive_Class,Object);
  425.   add_root(&Weak_Wrapper);
  426.   /* Do nil... */
  427.  
  428. #ifdef WITH_SMALL_CONSES
  429.   nil->CONS.car = nil;
  430.   nil->CONS.cdr = nil;
  431. #else
  432.   lval_classof(nil) = Null;
  433.   nil->CONS.car = nil;
  434.   nil->CONS.cdr = nil;
  435. #endif
  436.   { 
  437.     extern LispObject boot_thread;
  438.     lval_classof(boot_thread)=Thread;
  439.   }
  440.     
  441.  
  442.   gen_class(stacktop,&Basic_Structure,"structure",Structure_Class,Object);
  443.   add_root(&Basic_Structure);
  444.   allocate_static_integers(stacktop);
  445.  
  446. }
  447.